Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/permits.fr_/permits.fr

Text File | 1995-07-06 | 17KB | 499 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Permitter"
   ClientHeight    =   4350
   ClientLeft      =   690
   ClientTop       =   1875
   ClientWidth     =   6750
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   4755
   Left            =   630
   LinkTopic       =   "Form1"
   ScaleHeight     =   4350
   ScaleWidth      =   6750
   Top             =   1530
   Width           =   6870
   Begin VB.CommandButton cmdClose
      Caption         =   "&Close"
      Height          =   495
      Left            =   3780
      TabIndex        =   12
      Top             =   3540
      Width           =   1755
   End
   Begin VB.CommandButton cmdSave
      Caption         =   "S&ave Permissions"
      Height          =   555
      Left            =   1260
      TabIndex        =   11
      Top             =   3540
      Width           =   1755
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Delete Data"
      Enabled         =   0   'False
      Height          =   255
      Index           =   6
      Left            =   3720
      TabIndex        =   10
      Top             =   2940
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Insert Data"
      Enabled         =   0   'False
      Height          =   255
      Index           =   5
      Left            =   3720
      TabIndex        =   9
      Top             =   2640
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "Upda&te Data"
      Enabled         =   0   'False
      Height          =   255
      Index           =   4
      Left            =   3720
      TabIndex        =   8
      Top             =   2340
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "R&ead Data"
      Enabled         =   0   'False
      Height          =   255
      Index           =   3
      Left            =   3720
      TabIndex        =   7
      Top             =   2040
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "Admini&ster"
      Enabled         =   0   'False
      Height          =   255
      Index           =   2
      Left            =   960
      TabIndex        =   6
      Top             =   2940
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Modify Design"
      Enabled         =   0   'False
      Height          =   255
      Index           =   1
      Left            =   960
      TabIndex        =   5
      Top             =   2640
      Width           =   1875
   End
   Begin VB.CheckBox chkPermission
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Read Design"
      Enabled         =   0   'False
      Height          =   255
      Index           =   0
      Left            =   960
      TabIndex        =   4
      Top             =   2340
      Width           =   1875
   End
   Begin VB.ListBox lstTables
      Height          =   1395
      Left            =   3660
      TabIndex        =   1
      Top             =   360
      Width           =   2535
   End
   Begin VB.ListBox lstUsers
      Height          =   1395
      Left            =   360
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   360
      Width           =   2535
   End
   Begin VB.Label lblPermissions
      BackColor       =   &H00C0C0C0&
      Height          =   255
      Left            =   1620
      TabIndex        =   14
      Top             =   1920
      Width           =   1215
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Permissions:"
      Height          =   195
      Left            =   360
      TabIndex        =   13
      Top             =   1920
      Width           =   1065
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Tables and queries:"
      Height          =   195
      Left            =   3660
      TabIndex        =   3
      Top             =   120
      Width           =   1695
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Users:"
      Height          =   195
      Left            =   360
      TabIndex        =   2
      Top             =   120
      Width           =   555
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const P_READDESIGN = 0
Const P_MODIFYDESIGN = 1
Const P_ADMINISTER = 2
Const P_READDATA = 3
Const P_UPDATEDATA = 4
Const P_INSERTDATA = 5
Const P_DELETEDATA = 6

Const DBSEC_READDESIGN = 4
Const DBSEC_MODIFYDESIGN = 65756
Const DBSEC_ADMINISTER = 852478
Const DBSEC_READDATA = 20
Const DBSEC_UPDATEDATA = 84
Const DBSEC_INSERTDATA = 52
Const DBSEC_DELETEDATA = 148
Const DBSEC_MODIFYDESIGN_INSERTDATA = 65788
Const DBSEC_UPDATEINSERTDATA = 116
Const DBSEC_UPDATEDELETEDATA = 212
Const DBSEC_INSERTDELETEDATA = 180
Const DBSEC_UPDATEINSERTDELETEDATA = 244
Const DBSEC_NOPERMISSIONS = 0
Const DBSEC_READSEC = 131072

Const CHK_CHECKED = 1
Const CHK_UNCHECKED = 0

Private db As DATABASE
#If Win32 Then
    Private Declare Function GetWindowsDirectory Lib "Kernel32" _
        Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
        ByVal nSize As Long) As Long
#Else
    Private Declare Function GetWindowsDirectory Lib "Kernel" _
        (ByVal lpBuffer As String, _
        ByVal nSize As Integer) As Integer
#End If


Private Sub Form_Load()
    Dim myUser As String, myPass As String
    Dim i As Integer
    Dim winDir As String * 128
    Dim dirLen As Integer
    Dim dbName As String

    On Error GoTo LoadError

    ' Get the Windows directory and set the INI path.
    dirLen = GetWindowsDirectory(winDir, 128)
    If dirLen = 0 Then Error 32767
    DBEngine.IniPath = Left$(winDir, dirLen) & "\VBDBHT.INI"

    ' Set the user and passwords for initial login.
    myUser = "Admin"
    myPass = "theboss"
    DBEngine.DefaultUser = myUser
    DBEngine.DefaultPassword = myPass

    ' Get the database name and open the database.
    dbName = DataPath() & "\CHAPTER.09\ORDERS.MDB" ' DataPath() is in READINI.BAS
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)

    ' Fill the list boxes.
    FillUserList
    FillTableList
Exit Sub

LoadError:
    MsgBox Err.Description, vbCritical
End

End Sub


Sub FillUserList()
    Dim usr As User

    For Each usr In DBEngine.Workspaces(0).Users
        If UCase$(usr.Name) <> "CREATOR" And UCase$(usr.Name) <> "ENGINE" And UCase$(usr.Name) <> "ADMIN" Then
            lstUsers.AddItem usr.Name
        End If
    Next
End Sub

Sub FillTableList()
    Dim doc As Document

    For Each doc In db.Containers("Tables").Documents
        If Left$(doc.Name, 4) <> "MSys" Then lstTables.AddItem doc.Name
    Next

End Sub

Private Sub lstUsers_Click()
    Dim i As Integer

    If lstTables.ListIndex > -1 Then
        If ReadPermissions() = False Then
            lstUsers.ListIndex = -1
            For i = 0 To 6
                chkPermission(i).VALUE = CHK_UNCHECKED
                chkPermission(i).Enabled = False
            Next i
        End If
    End If
End Sub

Private Sub lstTables_Click()
    Dim i As Integer

    If lstUsers.ListIndex > -1 Then
        If ReadPermissions() = False Then
            lstTables.ListIndex = -1
            For i = 0 To 6
                chkPermission(i).VALUE = CHK_UNCHECKED
                chkPermission(i).Enabled = False
            Next i
        End If
    End If
End Sub

Function ReadPermissions() As Boolean
    Dim pass As String
    Dim i As Integer
    Dim permissionCode As Long
    Dim doc As Document

    On Error GoTo ReadPermissionsError

    Set doc = db.Containers("Tables").Documents(lstTables.TEXT)
    doc.UserName = lstUsers.TEXT

    For i = 0 To 6
        chkPermission(i).Enabled = True
        chkPermission(i).VALUE = CHK_UNCHECKED
    Next i
    lblPermissions.Caption = doc.Permissions
    permissionCode = doc.Permissions
    Select Case permissionCode
        Case DBSEC_ADMINISTER
            For i = 0 To 6
                chkPermission(i).VALUE = CHK_CHECKED
            Next i
        Case DBSEC_MODIFYDESIGN
            chkPermission(P_MODIFYDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
        Case DBSEC_UPDATEDATA
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
        Case DBSEC_DELETEDATA
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
        Case DBSEC_INSERTDATA
            chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
        Case DBSEC_READDATA
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
        Case DBSEC_READDESIGN
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
        Case DBSEC_MODIFYDESIGN_INSERTDATA
            chkPermission(P_MODIFYDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
        Case DBSEC_UPDATEINSERTDATA
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
        Case DBSEC_UPDATEDELETEDATA
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
        Case DBSEC_INSERTDELETEDATA
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
        Case DBSEC_UPDATEINSERTDELETEDATA
            chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
            chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            chkPermission(P_READDATA).VALUE = CHK_CHECKED
            chkPermission(P_DELETEDATA).VALUE = CHK_CHECKED
            chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
    End Select
    ReadPermissions = True

Exit Function
ReadPermissionsError:
    MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation
    ReadPermissions = False
Exit Function

End Function

Private Sub chkPermission_Click(Index As Integer)
    Dim i As Integer
    Select Case Index
        Case P_ADMINISTER
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                For i = 0 To 6
                    chkPermission(i).VALUE = CHK_CHECKED
                Next i
            End If
        Case P_READDESIGN
            If chkPermission(Index).VALUE = CHK_UNCHECKED Then
                For i = 0 To 6
                    chkPermission(i).VALUE = CHK_UNCHECKED
                Next i
            End If
        Case P_READDATA
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
            Else
                chkPermission(P_MODIFYDESIGN).VALUE = CHK_UNCHECKED
                chkPermission(P_UPDATEDATA).VALUE = CHK_UNCHECKED
                chkPermission(P_DELETEDATA).VALUE = CHK_UNCHECKED
                chkPermission(P_INSERTDATA).VALUE = CHK_UNCHECKED
                chkPermission(P_ADMINISTER).VALUE = CHK_UNCHECKED
            End If
        Case P_MODIFYDESIGN
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
                chkPermission(P_READDATA).VALUE = CHK_CHECKED
                chkPermission(P_UPDATEDATA).VALUE = CHK_CHECKED
                chkPermission(P_INSERTDATA).VALUE = CHK_CHECKED
            Else
                chkPermission(P_ADMINISTER).VALUE = CHK_UNCHECKED
            End If
        Case P_UPDATEDATA
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
                chkPermission(P_READDATA).VALUE = CHK_CHECKED
            Else
                chkPermission(P_ADMINISTER).VALUE = CHK_UNCHECKED
                chkPermission(P_MODIFYDESIGN).VALUE = CHK_UNCHECKED
            End If
        Case P_DELETEDATA
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
                chkPermission(P_READDATA).VALUE = CHK_CHECKED
            Else
                chkPermission(P_ADMINISTER).VALUE = CHK_UNCHECKED
                chkPermission(P_MODIFYDESIGN).VALUE = CHK_UNCHECKED
            End If
        Case P_INSERTDATA
            If chkPermission(Index).VALUE = CHK_CHECKED Then
                chkPermission(P_READDESIGN).VALUE = CHK_CHECKED
                chkPermission(P_READDATA).VALUE = CHK_CHECKED
            Else
                chkPermission(P_ADMINISTER).VALUE = CHK_UNCHECKED
            End If
    End Select


End Sub


Private Sub cmdSave_Click()
    Dim doc As Document
    Dim permissionCode As Long

    On Error GoTo SaveError

    Set doc = db.Containers("Tables").Documents(lstTables.TEXT)
    doc.UserName = lstUsers.TEXT
    If chkPermission(P_ADMINISTER) = CHK_CHECKED Then
        permissionCode = DBSEC_ADMINISTER
    ElseIf chkPermission(P_MODIFYDESIGN) = CHK_CHECKED Then
        If chkPermission(P_INSERTDATA) = CHK_CHECKED Then
            permissionCode = DBSEC_MODIFYDESIGN_INSERTDATA
        Else
            permissionCode = DBSEC_MODIFYDESIGN
        End If
    ElseIf chkPermission(P_UPDATEDATA) = CHK_CHECKED Then
        If chkPermission(P_INSERTDATA) = CHK_CHECKED Then
            If chkPermission(P_DELETEDATA) = CHK_CHECKED Then
                permissionCode = DBSEC_UPDATEINSERTDELETEDATA
            Else
                permissionCode = DBSEC_UPDATEINSERTDATA
            End If
        Else
            permissionCode = DBSEC_UPDATEDATA
        End If
    ElseIf chkPermission(P_INSERTDATA) = CHK_CHECKED Then
        If chkPermission(P_DELETEDATA) = CHK_CHECKED Then
            permissionCode = DBSEC_INSERTDELETEDATA
        Else
            permissionCode = DBSEC_INSERTDATA
        End If
    ElseIf chkPermission(P_DELETEDATA) = CHK_CHECKED Then
        permissionCode = DBSEC_DELETEDATA
    ElseIf chkPermission(P_READDATA) = CHK_CHECKED Then
        permissionCode = DBSEC_READDATA
    ElseIf chkPermission(P_READDESIGN) = CHK_CHECKED Then
        permissionCode = DBSEC_READDESIGN
    Else
        permissionCode = DBSEC_NOPERMISSIONS
    End If
    If UCase$(doc.UserName) = "ADMIN" Then permissionCode = permissionCode + DBSEC_READSEC
    doc.Permissions = permissionCode
    lblPermissions.Caption = doc.Permissions
Exit Sub
SaveError:
    MsgBox Err.Description & " (" & Err.Number & ")"
Exit Sub
End Sub

Private Sub cmdClose_Click()
    End
End Sub